home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / list.t < prev    next >
Text File  |  1989-06-30  |  12KB  |  380 lines
  1. (herald list (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26.  
  27. ;;;; list utilities, part 1
  28.  
  29. (define-constant dot-char #\.)
  30. (define-integrable (dot-char? ch) (char= ch dot-char))
  31.  
  32. (lset *list-begin-char*  #\left-paren)
  33. (lset *list-end-char*    #\right-paren)
  34.  
  35. ;;;; miscellaneous
  36.  
  37. (define (list . l) l)
  38.  
  39. (define (cons* first . rest)            ; hackola definition
  40.   (cond ((null? rest) first)
  41.         (else 
  42.          (do ((r rest (cdr r))
  43.                       (q rest r))
  44.                   ((null? (cdr r))
  45.                    (set (cdr q) (car r))
  46.                    (set (car r) first)
  47.                    (if (neq? r rest) (set (cdr r) rest))
  48.                    r)))))
  49.  
  50. (define (losing-non-null-list x)
  51.   (error "expected a list, but got an atom instead~%  (... . ~s)"
  52.          x)
  53.   t)
  54.  
  55. (define (length l)
  56.   (do ((i 0. (fx+ i 1))
  57.        (l l (cdr l)))
  58.       ((null-list? l) i)))
  59.  
  60. ;;; this really belongs elsewhere.
  61. ;;; incredibly hacked-up version to bum the shit out.
  62.  
  63. (define (map1 proc l)
  64.   (cond ((null-list? l) '())
  65.         (else
  66.          (let ((result (%make-pair)))
  67.            (set (car result) (proc (car l)))
  68.            (iterate loop ((l (cdr l)) (r result))
  69.              (cond ((null-list? l)
  70.                     (set (cdr r) '())
  71.                     result)
  72.                    (else
  73.                     (let ((q (%make-pair)))
  74.                       (set (cdr r) q)
  75.                       (set (car q) (proc (car l)))
  76.                       (loop (cdr l) q)))))))))
  77.  
  78. (define-constant value-of-walk (undefined-value "value of WALK"))
  79.  
  80. (define (walk1 proc l)
  81.   (iterate loop ((l l))
  82.     (cond ((null-list? l) value-of-walk )
  83.           (else
  84.            (proc (car l))
  85.            (loop (cdr l))))))
  86.  
  87. ;;; mem = membership in list
  88.  
  89. (define (mem pred obj list)
  90.   (iterate mem ((list list))
  91.     (cond ((null-list? list) nil)
  92.           ((pred obj (car list)) list)
  93.           (else (mem (cdr list))))))
  94.  
  95. (define (memq obj list)
  96.   (iterate memq ((list list))
  97.     (cond ((null-list? list) nil)
  98.           ((eq? obj (car list)) list)
  99.           (else (memq (cdr list))))))
  100.  
  101. (define (bad-list-index . rest)
  102.   (error "illegal index into list~%  ~s" rest))
  103.  
  104. (define (nthcdr list index)
  105.   (let ((index (enforce nonnegative-fixnum? index)))
  106.     (iterate loop ((l list) (i index))
  107.       (cond ((fx= i 0) l)
  108.             ((null-list? l)
  109.              (bad-list-index 'nthcdr list index))
  110.             (else (loop (cdr l) (fx- i 1)))))))
  111.  
  112. ;;; set-nthcdr
  113.  
  114. (define nth
  115.   (object (lambda (list index)
  116.             (let ((index (enforce nonnegative-fixnum? index)))
  117.               (iterate loop ((l list) (i index))
  118.                 (cond ((null-list? l)
  119.                        (bad-list-index 'nth list index))
  120.                       ((fx= i 0) (car l))
  121.                       (else (loop (cdr l) (fx- i 1)))))))
  122.           ((setter self) set-nth)))
  123.  
  124. (define (set-nth %%list index value)
  125.   (let ((index (enforce nonnegative-fixnum? index)))
  126.     (iterate loop ((l %%list) (i index))
  127.       (cond ((null-list? l)
  128.              (bad-list-index 'set `(nth ,%%list ,index) value))   ; whattahack
  129.             ((fx= i 0) (set (car l) value))
  130.             (else (loop (cdr l) (fx- i 1)))))))
  131.  
  132. (define last
  133.   (object (lambda (list)
  134.             (car (lastcdr list)))
  135.           ((setter self) set-last)))
  136.  
  137. (define (set-last list value)
  138.   (set (car (lastcdr list)) value))
  139.  
  140. (define (lastcdr list)
  141.   (let ((list (enforce pair? list)))
  142.     (iterate loop ((list list))
  143.       (if (not (pair? (cdr list))) 
  144.           list
  145.           (loop (cdr list))))))
  146.  
  147.  
  148. ;;;; reverse, append, ...
  149. ;;;           maclisp                           <t>
  150.  
  151. ;;;     safe            unsafe          safe            unsafe
  152. ;;;
  153. ;;;     reverse         nreverse        reverse         reverse!
  154. ;;;     append          nconc           append          append!
  155. ;;;     ---             nreconc         append-reverse  append-reverse!
  156.  
  157. (define (append . lists)
  158.   (labels (((append2 l1 l2)
  159.             (if (null-list? l1) l2
  160.                 (cons (car l1) (append2 (cdr l1) l2)))))
  161.     (cond ((null? lists) '())
  162.           ((null? (cdr lists)) (car lists))
  163.           ((null? (cddr lists)) (append2 (car lists) (cadr lists)))
  164.           (else (append (car lists) (apply append (cdr lists)))))))
  165.  
  166. (define (append! . lists) ; note: (append! 'atom 'anything) => anything
  167.   (cond ((null? lists)  '())
  168.         ((null? (cdr lists)) (car lists))
  169.         ((null? (cddr lists))
  170.          (cond ((null-list? (car lists))
  171.                 (cadr lists))
  172.                (else
  173.                 (set (cdr (lastcdr (car lists)))
  174.                      (cadr lists))
  175.                 (car lists))))
  176.         (else (append! (car lists)
  177.                        (apply append! (cdr lists))))))
  178.  
  179. (define-recursive (append-reverse list seed)
  180.   (if (null-list? list) 
  181.     seed
  182.     (append-reverse (cdr list) (cons (car list) seed))))
  183.  
  184. (define (append-reverse! old-list seed)
  185.   (cond ((null-list? old-list) seed)
  186.         (else
  187.          (iterate loop ((old-cdr (cdr old-list))
  188.                         (old-car seed)
  189.                         (tail    old-list))
  190.            (cond ((null-list? (cdr tail))
  191.                   (set (cdr tail) old-car)
  192.                   tail)
  193.                  (else
  194.                   (set (cdr tail) old-car)
  195.                   (loop (cdr old-cdr) tail old-cdr)))))))
  196.  
  197. (define (reverse list)
  198.   (append-reverse list '()))
  199.  
  200. (define (reverse! old-list)
  201.   (append-reverse! old-list '()))
  202.  
  203. (define (copy-list list) (append list '()))
  204.  
  205. ;;; ass = association-list lookup
  206.  
  207. (define (ass pred obj list)
  208.   (iterate loop ((list list))
  209.     (cond ((null-list? list) nil)
  210.           ((pred obj (caar list)) (car list))
  211.           (else (loop (cdr list))))))
  212.  
  213. (define-integrable (ass? pred obj list)
  214.   (if (ass pred obj list) t nil))
  215.  
  216. (define (assq obj list)
  217.   (iterate loop ((l list))
  218.     (if (null-list? l) 
  219.         nil
  220.         (let ((z (car l)))
  221.           (cond ((not (pair? z))
  222.                  (loop (cons (error '("association list contains non-pair~%"
  223.                                       "  (assq ~s ~s)")
  224.                                     obj
  225.                                     list)
  226.                              (cdr l))))
  227.                 ((eq? obj (car z)) z)
  228.                 (else (loop (cdr l))))))))
  229.  
  230. (define-integrable (assq? obj list) (true? (assq obj list)))
  231.  
  232. ;;; questionable cruft.  print-char wants rass.
  233.  
  234. (define (rass pred item alist)
  235.   (iterate loop ((a alist))
  236.     (cond ((null-list? a) nil)
  237.           ((pred item (cdar a)) (car a))
  238.           (else (loop (cdr a))))))
  239.  
  240. (define (rassq item alist)
  241.   (iterate loop ((a alist))
  242.     (cond ((null-list? a) nil)
  243.           ((eq? item (cdar a)) (car a))
  244.           (else (loop (cdr a))))))
  245.  
  246.  
  247. (define (circular? move x)
  248.   (if (null-list? x) 
  249.       nil
  250.       (iterate race ((slow-runner x) (fast-runner (move x)))
  251.         (cond ((or (null-list? fast-runner) 
  252.                    (null-list? (move fast-runner))) 
  253.                nil)
  254.               ((eq? slow-runner fast-runner) t) ;fast runner caught up!
  255.               (else
  256.                (race (move slow-runner) (move (move fast-runner))))))))
  257.  
  258. (define (proper-list? x)
  259.   (if (atom? x) 
  260.       (null? x)
  261.       (proper-list? (cdr x))))
  262.  
  263. (define (sublist l start count)
  264.   (iterate loop ((i count)
  265.                  (ll (nthcdr l start))
  266.                  (result '()))
  267.     (cond ((fx<= i 0) (reverse! result))
  268.           ((null-list? ll)
  269.            (error "argument list is too short~%  (~s ~s ~s ~s)"
  270.                   'sublist l start count))
  271.           (else
  272.            (loop (fx- i 1)
  273.                  (cdr ll)
  274.                  (cons (car ll) result))))))
  275.  
  276.  
  277.  
  278. ;;; del = deletion from list
  279.  
  280. (define (del pred obj list)
  281.   (iterate del ((list list))
  282.     (cond ((null-list? list) '())
  283.           ((pred obj (car list))
  284.            (del (cdr list)))
  285.           ((mem pred obj (cdr list))
  286.            (cons (car list) (del (cdr list))))
  287.           (else list))))
  288.  
  289. (define-integrable (delq obj list) (del eq? obj list))
  290.  
  291. (define (del! pred obj list)     
  292.   (iterate del! ((list list))
  293.     (cond ((null-list? list) '())
  294.           ((pred obj (car list)) (del! (cdr list)))
  295.           (else (set (cdr list) (del! (cdr list)))
  296.                 list))))
  297.  
  298.  
  299. (define (delq! obj list)     
  300.   (iterate delq! ((list list))
  301.     (cond ((null-list? list) '())
  302.           ((eq? obj (car list)) (delq! (cdr list)))
  303.           (else (set (cdr list) (delq! (cdr list)))
  304.                 list))))
  305.  
  306.  
  307.  
  308. ;;;; questionable cruft.  t compiler wants it.  print-char wants rass.
  309. ;;; what to do about sequence functions?  be common-lisp compatible?
  310.  
  311. (define (pos pred obj l)
  312.   (iterate loop ((l l)
  313.                  (n 0))
  314.     (cond ((null-list? l) nil)
  315.           ((pred obj (car l)) n)
  316.           (else (loop (cdr l) (fx+ n 1))))))
  317.  
  318. (define-integrable (posq obj l) (pos eq? obj l))
  319.  
  320.  
  321. ;;; make this open-coded someday.
  322. (define (displace x y)
  323.   (let ((x (enforce pair? x))
  324.         (y (enforce pair? y)))
  325.     (set (car x) (car y))
  326.     (set (cdr x) (cdr y))
  327.     x))
  328.  
  329. ;;; The pair handler
  330.  
  331. (define handle-pair
  332.   (object nil
  333.     ((hash self)
  334.      (if (null? self) 0 (fx+ (hash (car self)) (hash (cdr self)))))
  335.     ((display obj port)
  336.      (write-pair port obj 0 nil))
  337.     ((print obj port)
  338.      (write-pair port obj 0 t))
  339.     ((pretty-print obj port) (pp-list obj port))
  340.     ((maybe-crawl-component pair command)
  341.      (cond ((and (nonnegative-fixnum? command)
  342.                  (fx< command (length pair)))
  343.             (crawl-push (nth pair command)))
  344.            (else nil)))))
  345.  
  346. (define print-level-excess "(...)")
  347. (define print-length-excess "...")
  348. (lset *print-level*  most-positive-fixnum)
  349. (lset *print-length* most-positive-fixnum)
  350.  
  351. ;;; Recursively prints the object.  Currently doesn't check for
  352. ;;; circular structure.
  353.  
  354. (define (write-pair port obj level slashify?)
  355.   (let ((writec (if (iob? port) vm-write-char write-char))
  356.         (writes (if (iob? port) vm-write-string write-string)))
  357.     (cond ((null? obj)
  358.            (writec port *list-begin-char*)
  359.            (writec port *list-end-char*))
  360.           ((atom? obj)               (print obj port))
  361.           ((not (reasonable? obj))   (print-random obj port))
  362.           ((fx> level *print-level*) (writes port print-level-excess))
  363.           (else
  364.            (writec port *list-begin-char*)
  365.            (iterate loop ((l obj) (n 0) (flag '#f))
  366.              (cond ((atom? l)
  367.                     (cond ((not (null? l))
  368.                            (space port)
  369.                            (writec port dot-char)
  370.                            (space port)
  371.                            (write-pair port l (fx+ level 1) slashify?))))
  372.                    (else
  373.                     (if flag (space port))
  374.                     (cond ((fx>= n *print-length*)
  375.                            (writes port print-length-excess))
  376.                           (else
  377.                            (write-pair port (car l) (fx+ level 1) slashify?)
  378.                            (loop (cdr l) (fx+ n 1) '#t))))))
  379.            (writec port *list-end-char*)))))
  380.